home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / assem-check.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  9.0 KB  |  272 lines
  1. ;;; -*- Package: ASSEMBLER -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: assem-check.lisp,v 1.3 91/10/18 17:59:10 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    Stuff to verify the legality of register allocation by examining the
  15. ;;; assembly output.  If the same register holds two things (live TNs) at the
  16. ;;; same time, we have a problem.
  17. ;;;
  18. (in-package "ASSEMBLER")
  19. (export '(segment-check-registers))
  20. (in-package "C")
  21. (import '(do-live-tns ir2-block-live-in ir2-block-block print-tn sb-kind tn
  22.       vop-block vop-info vop-info-save-p vop-save-set tn-reads tn-kind
  23.       tn-number tn-writes vop-refs vop vop-info-arg-costs
  24.       vop-info-result-costs vop-info-move-args vop-results vop-args
  25.       vop-temps vop-info-arg-types vop-info-name)
  26.     "ASSEMBLER")
  27. (in-package "ASSEMBLER")
  28.  
  29. ;;; The segment we are currently checking.
  30. ;;;
  31. (defvar *check-segment*)
  32.  
  33. ;;; The exclusive end of the block we are currently checking.
  34. ;;;
  35. (defvar *check-end*)
  36.  
  37. ;;; REGISTER-LOSSAGE-ERROR  --  Internal
  38. ;;;
  39. ;;;    Print out a hopefully-descriptive error message describing the context
  40. ;;; in which a register is twice-used.  Old is the cons (TN . Instruction)
  41. ;;; describing the previously live value.
  42. ;;;
  43. (defun register-lossage-error (sb offset tn write-p old inst)
  44.   (let ((tn-name (with-output-to-string (s)
  45.            (print-tn tn s)))
  46.     (old-name (with-output-to-string (s)
  47.             (print-tn (car old) s)))
  48.     (old-inst (cdr old)))
  49.     (cerror "Ignore it."
  50.         "Location ~D in ~A SB in use by both ~A and ~A:~%~A~&"
  51.         offset (sb-name sb) tn-name old-name
  52.         (with-output-to-string (s)
  53.           (dump-segment
  54.            *check-segment* :stream s
  55.            :start inst :end (if old-inst (node-next old-inst) *check-end*)
  56.            :markers `((,inst "*** ~A ~:[read~;written~] here:~%"
  57.                  ,tn-name ,write-p)
  58.               (,(cdr old) "*** ~A read here:~%" ,old-name)))))))
  59.  
  60.  
  61. ;;; FIND-TARGETING-PATH  --  Internal
  62. ;;;
  63. ;;;    Return true if TN is targeted into Old-TN (possibly indirectly through
  64. ;;; multiple TNs.)  We do a graph walk to find indirect targeting paths.  Flags
  65. ;;; is has a T entry for every TN that we have already reached during the walk.
  66. ;;;
  67. (defun find-targeting-path (tn old-tn flags)
  68.   (cond
  69.    ((gethash tn flags) nil)
  70.    (t
  71.     (setf (gethash tn flags) t)
  72.     (do ((ref (tn-reads tn) (tn-ref-next ref)))
  73.     ((null ref) nil)
  74.       (let ((target (tn-ref-target ref)))
  75.     (when target
  76.       (let ((ttn (tn-ref-tn target)))
  77.         (when (or (eq ttn old-tn)
  78.               (eq (tn-ref-load-tn target) old-tn)
  79.               (find-targeting-path ttn old-tn flags))
  80.           (return t)))))))))
  81.  
  82. (defparameter ignored-optimizable-vops '(c:allocate-full-call-frame))
  83.  
  84. ;;; CHECK-FOR-EXCEPTIONS  --  Internal
  85. ;;;
  86. ;;;   This is one place where a hueristic component enters.  We ignore
  87. ;;; sequences where the first TN (TN) is targeted into the second TN (Old)
  88. ;;; along a read path.  If TN is a load-tn, then we scan the refs for Inst's
  89. ;;; VOP to find the original TN.
  90. ;;;
  91. ;;;   We also ignore any cases where Old is written by certain VOPs that can be
  92. ;;; entirely optimized away.
  93. ;;;
  94. (defun check-for-exceptions (tn old write-p inst)
  95.   (declare (ignore write-p))
  96.   (or (find-targeting-path 
  97.        (if (eq (tn-kind tn) :load)
  98.        (do ((ref (vop-refs (node-vop inst))
  99.              (tn-ref-next-ref ref)))
  100.            ((eq (tn-ref-load-tn ref) tn) (tn-ref-tn ref)))
  101.        tn)
  102.        (car old)
  103.        (make-hash-table :test #'eq))
  104.       (do ((ref (tn-writes (car old)) (tn-ref-next ref)))
  105.       ((null ref) nil)
  106.     (when (member (vop-info-name (vop-info (tn-ref-vop ref)))
  107.               ignored-optimizable-vops)
  108.       (return t)))))
  109.  
  110.  
  111. ;;; NOTE-TN-REF  --  Internal
  112. ;;;
  113. ;;;    Notice a reference to TN by Inst.  If there is a problem, signal an
  114. ;;; error.  If the TN has no number, we guess that it is a random TN (not
  115. ;;; allocated by the allocator), so we ignore the reference.
  116. ;;;
  117. (defun note-tn-ref (tn write-p inst)
  118.   (if (tn-number tn)
  119.       (let* ((sc (tn-sc tn))
  120.          (sb (sc-sb sc)))
  121.     (when (eq (sb-kind sb) :finite)
  122.       (let ((live (finite-sb-live-tns sb)))
  123.         (loop for i from (tn-offset tn)
  124.           repeat (sc-element-size sc) do
  125.           (let ((old (svref live i)))
  126.         (when (and old (not (eq (car old) tn))
  127.                (not (check-for-exceptions tn old write-p inst)))
  128.           (register-lossage-error sb i tn write-p old inst)))
  129.           (setf (svref live i) (if write-p nil (cons tn inst)))))))
  130.       (assert (and (eq (tn-kind tn) :normal)
  131.            (not (or (tn-reads tn) (tn-writes tn))))))
  132.  
  133.   (undefined-value))
  134.  
  135.  
  136. ;;; CLEAR-LIVE-SET  --  Internal
  137. ;;;
  138. ;;;    Mark all registers as unused.
  139. ;;;
  140. (defun clear-live-set ()
  141.   (dolist (sb (backend-sb-list *backend*))
  142.     (when (eq (sb-kind sb) :finite)
  143.       (fill (finite-sb-live-tns sb) nil))))
  144.  
  145.  
  146. ;;; CHECK-BLOCK-INIT  --  Internal
  147. ;;;
  148. ;;;    Set up the FINITE-SB-LIVE-TNS to represent the TNs live at a particular
  149. ;;; point.  We mark the TNs, but record no instruction, since we don't know
  150. ;;; where the read is.
  151. ;;;
  152. (defun check-block-init (block live)
  153.   (clear-live-set)
  154.   (do-live-tns (tn live block)
  155.     (let* ((sc (tn-sc tn))
  156.        (sb (sc-sb sc)))
  157.       (when (eq (sb-kind sb) :finite)
  158.     (loop for offset from (tn-offset tn)
  159.           repeat (sc-element-size sc) do
  160.       (setf (svref (finite-sb-live-tns sb) offset)
  161.         (cons tn nil))))))
  162.   (undefined-value))
  163.  
  164.  
  165. ;;; NOTE-MORE-REFS  --  Internal
  166. ;;;
  167. ;;;    Do NOTE-TN-REF on the more operand to a VOP.  Costs are the fixed
  168. ;;; operand costs (to skip them.)  Ops is the full arg/result list.  
  169. ;;;
  170. (defun note-more-refs (costs ops write-p inst)
  171.   (do ((cost costs (cdr cost))
  172.        (op ops (tn-ref-across op)))
  173.       ((null cost)
  174.        (do ((op op (tn-ref-across op)))
  175.        ((null op))
  176.      (note-tn-ref (tn-ref-tn op) write-p inst))))
  177.   (undefined-value))
  178.  
  179.  
  180. ;;; FIND-BRANCH-TARGETS  --  Internal
  181. ;;;
  182. ;;;    Return a bit-vector with 1 elements for the offsets of all labels that
  183. ;;; have an intra-block jump to them.  Labels with no VOP are block start
  184. ;;; labels.
  185. ;;;
  186. (defun find-branch-targets (elsewhere)
  187.   (let* ((last (label-%position elsewhere))
  188.      (res (make-array (1+ last) :element-type 'bit :initial-element 0)))
  189.     (do ((node (node-prev elsewhere) (node-prev node))) 
  190.     ((null node))
  191.       (when (and (instruction-p node)
  192.          (inst-class-p node relative-branch))
  193.     (do-constants (lab node)
  194.       (when (label-p lab)
  195.         (let ((lab-vop (node-vop lab)))
  196.           (when (and lab-vop
  197.              (eq (ir2-block-block (vop-block lab-vop))
  198.                  (ir2-block-block (vop-block (node-vop node)))))
  199.         (let ((pos (label-%position lab)))
  200.           (when (<= pos last)
  201.             (setf (sbit res pos) 1)))))))))
  202.     res))
  203.  
  204.  
  205. ;;; Call VOPs that don't happen to have the MOVE-ARGUMENTS attribute.
  206. ;;;
  207. (defparameter stray-call-vops '(c:call-variable c:call-out))
  208.  
  209. ;;; SEGMENT-CHECK-REGISTERS  --  Interface
  210. ;;;
  211. ;;;    Check the validity of register allocation in a segment.  Elsewhere is
  212. ;;; the (now inserted) elsewhere segment, which we use to determine the start
  213. ;;; of elsewhere code (so that we can ignore it.)  We detect most (but not all)
  214. ;;; allocation errors.  Code for each Ir2-block must be contiguous (so this
  215. ;;; must be called before assembly optimization.)  We go back to the IR2 to
  216. ;;; find the live TNs at block ends and call sites.
  217. ;;;
  218. ;;;    We clear the live set at all labels that are the target of intra-block
  219. ;;; jumps, since there might be some weird control flow going on that could
  220. ;;; cause spurious errors.
  221. ;;;
  222. (defun segment-check-registers (*check-segment* elsewhere)
  223.   (let ((*check-end* nil)
  224.     (targets (find-branch-targets elsewhere))
  225.     (call-vop nil)
  226.     (state :normal)
  227.     (block nil))
  228.     (declare (type (member :normal :call :assembly-call) state)
  229.          (inline member))
  230.     (do ((node (node-prev elsewhere) (node-prev node))) 
  231.     ((null node))
  232.       (typecase node
  233.     (instruction
  234.      (let* ((vop (node-vop node))
  235.         (info (vop-info vop)))
  236.        (unless (eq call-vop vop)
  237.          (ecase state
  238.            (:call
  239.         (note-more-refs (vop-info-arg-costs (vop-info call-vop))
  240.                 (vop-args call-vop)
  241.                 nil (node-next node)))
  242.            ((:assembly-call :normal)))
  243.          (setq state :normal))
  244.        
  245.        (when (eq state :normal)
  246.          (let ((vblock (vop-block vop)))
  247.            (unless (eq vblock block)
  248.          (setq block vblock)
  249.          (setq *check-end* (node-next node))
  250.          (check-block-init block (ir2-block-live-in block))))
  251.          
  252.          (cond
  253.           ((or (vop-info-move-args info)
  254.            (member (vop-info-name info) stray-call-vops
  255.                :test #'eq))
  256.            (setq state :call  call-vop vop)
  257.            (note-more-refs (vop-info-result-costs info)
  258.                    (vop-results vop) t node))
  259.           ((inst-class-p node assembly-call)
  260.            (setq state :assembly-call  call-vop vop)
  261.            (note-more-refs nil (vop-temps vop) t node))))
  262.        
  263.        (do-results (res node)
  264.          (note-tn-ref res t node))
  265.        (do-arguments (arg node)
  266.          (note-tn-ref arg nil node))))
  267.     (label
  268.      (unless (zerop (sbit targets (label-%position node)))
  269.        (clear-live-set))))))
  270.        
  271.   (undefined-value))
  272.